home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
The Original Shareware 1.1
/
The Original Shareware (WeMake CDs)(Volume 1.1)(CDs, Inc)(1993).iso
/
19
/
dir_srch.zip
/
DIRSEARC.PAS
Wrap
Pascal/Delphi Source File
|
1987-09-07
|
18KB
|
650 lines
{$G512,P512}
{ The above compiler directives allow the I/O redirection, I use this
to be able to type control P to direct the output to the printer
as well as the screen when using this program from command.com.
These directives WILL NOT WORK unless you have version 3. To disable
these directives change the '$' to '*' to allow reversal of the
procedure later.
}
{$V-}
{ Simple whole disk catalog program.
This program will search the entire disk for a file and print out the
directory information found. The entries follow the following rules.
for Dir:
leave blank for current directory,
if you want the entire disk searched enter just a back slash,
if you wanta search started at a particular directory then
completely specify that directory( for example C:\turbo\irs\)
the trailing backslash is required.
for File Mask:
use the rules for wild card specification spelled out in the
DOS manual. ( for example: *.* , att*.* , ??.* and so on )
Search Sub Directories:
if you enter 'Y' or 'y' to this responce the program will
search for any subdirectories encountered when starting at
the specified input.
This program will also check the command line buffer for input
to allow the program to be used from the command.com with a
command line. If you enter just one entry on the command line
then it will be assumed to be the file mask and the current
directory will be searched but not sub directories. If you
enter two entries on the command line the first one will be assumed
to be the file mask and the 2nd whether to search sub directories.
If you enter three entries the first is the Dir to start at, the
2nd the File mask, and the third whether sub directories should be
searched.
examples:
catalog *.bak - look for all *.bak's in the current dir.
catalog *.bak y - look for all *.bak's from the current dir
to the last sub dir on this path.
catalog \turbo\ *.bak y - look for all the *.bak's starting at
the \turbo point in the path to the
last sub dir on this path.
catalog \ *.bak y - search the disk stating at the root for all
*.bak's .
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
This program travels through the directory using a method called
pre-order traversal. That means as you look at each entry in a dir
for a match, if the entry is another dir then that dir will be checked
before looking at the next entry in the current dir. This also means that
when the end of the start director is hit the program is done.
Because of the search method used the order of the print out can be
confusing, I could fix it but this program works for what I use it for.
}
program Catalog;
type
AnyString = String[255];
Str80 = String[80];
CommandLine = string[128];
CmdArray = Array[1..20] of CommandLine;
Var
FileMask,
DirMask : String[80];
SubDir : boolean;
Error,
No,
I : integer;
Subs,
Continue : Char;
Sline : CommandLine;
Entries : CmdArray;
{*I bios.pas }
type
Bios = Record
AX,BX,CX,DX,BP,SI,DI,DS,ES,Flags:Integer;
end;
BiosB = Record
AL,AH,BL,BH,CL,CH,DL,DH:Byte;
end;
DTA = String[80];
procedure GetDate(var Year,Month,Day:Integer);
var
Reg : Bios;
RegB : BiosB absolute Reg;
begin
RegB.AH:=$2A;
MsDos(Reg);
Year:=Reg.CX;
Month:=RegB.DH;
Day:=RegB.DL;
end;
Procedure GetTime(var Hrs,Min,Sec,HSec:Integer);
var
Reg : Bios;
RegB : BiosB absolute Reg;
begin
RegB.AH:=$2C;
MsDos(Reg);
Hrs:=RegB.CH;
Min:=RegB.CL;
Sec:=RegB.DH;
HSec:=RegB.DL;
end;
Procedure GetIntr(IntrNumber:integer;var CodeSegment,Offset,Error:Integer);
var
Reg : Bios;
RegB : BiosB absolute Reg;
begin
Error:=0;
RegB.AH:=$35;
RegB.AL:=IntrNumber;
MsDos(Reg);
CodeSegment:=Reg.ES;
Offset:=Reg.BX;
If (Reg.Flags And 1)=1 then Error:=RegB.AL;
end;
Procedure MakeDir(DataSegment,Offset:Integer;var Error:integer);
var
Reg : Bios;
RegB : BiosB absolute Reg;
Begin
Error:=0;
RegB.AH:=$39;
Reg.DS:=DataSegment;
Reg.DX:=Offset;
MsDos(Reg);
If (Reg.Flags And 1)=1 then Error:=RegB.AL;
end;
Procedure RemoveDir(DataSegment,Offset:Integer;var Error:integer);
var
Reg : Bios;
RegB : BiosB absolute Reg;
Begin
Error:=0;
RegB.AH:=$3A;
Reg.DS:=DataSegment;
Reg.DX:=Offset;
MsDos(Reg);
If (Reg.Flags And 1)=1 then Error:=RegB.AL;
end;
Procedure GetCurrentDir(var Name:DTA;var Error:integer);
var
Reg : Bios;
RegB : BiosB absolute Reg;
I : Integer;
Begin
Error:=0;
Name[0]:=Chr(0);
RegB.AH:=$47;
Reg.DS:=Seg(Name);
Reg.SI:=Ofs(Name)+1;
RegB.DL:=0;
MsDos(Reg);
If (Reg.Flags And 1)=1 then Error:=RegB.AL;
If Error=0 then
begin
I:=0;
repeat
I:=I+1;
Until (I=64) or (Name[I]=Chr(0));
Name[0]:=Chr(I);
end;
end;
{*I bios2.pas }
type
Registers= Record Case Integer Of
1: (AX,BX,CX,DX,BP,SI,DI,DS,ES,Flags: Integer);
2: (al,ah,bl,bh,cl,ch,dl,dh: Byte);
End;
String80 = string[80];
procedure SetDTA(MEMSeg,MEMOff:Integer;var Err:Integer );
var
DOSRegs : Registers;
begin
With DOSRegs do
begin
Err := 0; { Assume No Error }
ah := $1A; { Function used to set the DTA }
DS := MEMSeg; { store the parameter Segment in DS }
DX := MEMOff; { " " " Offset in DX }
MSDos( DOSRegs );
If (Flags And 1) = 1 then
Err := al;
end;
end;
procedure GetDTA(var MEMSeg,MEMOff:Integer;
var Err : Integer );
var
DOSRegs : Registers;
begin
With DOSRegs do
begin
ah := $2F; { Function used to get current DTA address }
MSDos( DOSRegs );
MEMSeg := ES; { Segment of DTA returned by DOS }
MEMOff := BX; { Offset of DTA returned }
If (Flags and 1)=1 then
Err := al;
end;
end;
procedure GetFirstFile( Mask : String80; var NamR : String80;
MEMSeg, MEMOff : Integer; Option : Integer;
var Err : Integer );
var
DOSRegs : Registers;
I : Integer;
begin
With DOSRegs do
begin
Err := 0;
ah := $4E; { Get first directory entry }
DS := Seg( Mask ); { Point to the file Mask }
DX := Ofs( Mask )+1;
CX := Option; { Store the Option }
MSDos( DOSRegs );
If (Flags and 1)=1 then
Err := al;
end;
I := 1;
repeat
NamR[ I ] := Chr( mem[ MEMSeg : MEMOff + 29 + I ] );
I := I + 1;
until ( not ( NamR[ I - 1 ] in [ ' '..'~' ] ));
NamR[ 0 ] := Chr( I - 1 );
end;
procedure GetNextFile( var NamR : String80; MEMSeg, MEMOff : Integer;
Option : Integer; var Err : Integer );
var
DOSRegs : Registers;
I : Integer;
begin
With DOSRegs do
begin
Err := 0;
ah := $4F; { Function used to get the next }
{ directory entry }
CX := Option; { Set the file option }
MSDos( DOSRegs );
If (Flags and 1)=1 then
Err := al;
end;
I := 1;
repeat
NamR[ I ] := Chr( mem[ MEMSeg : MEMOff + 29 + I ] );
I := I + 1;
until ( not ( NamR[ I - 1 ] in [ ' '..'~' ] ));
NamR[ 0 ] := Chr( I - 1 );
end;
{*I hexout.pas }
type
hex_string = string[4];
function hexout(i:integer):hex_string;
{ take integer return hex for it in a string }
var
dummy:string[4];
j,k:integer;
begin
for j:=1 to 4 do
begin
k:= i and $000F;
if k > 9 then k:=k+7;
dummy[5-j]:=chr(k+48);
i:= i shr 4
end;
dummy[0]:=chr(4);
hexout:=dummy
end;
{*I parse.pas }
procedure parse(S:CommandLine;var No:integer;Var E:CmdArray);
var
k : integer;
D : CommandLine;
begin
No:=ParamCount;
for k:=1 to No do
E[k]:=ParamStr(k);
end;
{*I fcb.inc }
type
FCB_Layout = record
Drive : byte;
FileName : Array[1..8] of char;
FileExt : Array[1..3] of char;
CurBlock : integer;
RecSize : integer;
FSizeLow : integer;
FSizeHigh : integer;
CreateDate : integer;
CreateTime : integer;
Flags : byte;
DiskAddr1st : integer;
DiskAddrLst : integer;
LastAccess : Array [1..3] of byte;
NextRecord : byte;
RelRecLow : integer;
RelRecHigh : integer;
end;
{*I filecomp.pas}
function WildStrComp(S,A:Str80):boolean;
{ this function compares two strings, string A can contain '?' }
{ which match anything. }
Var
I,J : Integer;
Done,
Match : boolean;
begin
Match:=true;
I:=1;
J:=Length(A);
Done:=false;
If Length(A)<>Length(S) then
Match:=false
Else
begin
While Match and not Done do
begin
If ( I > J ) then Done:=true
Else
If A[I]<>'?' then
If UpCase(A[I])<>UpCase(S[I]) then
Match:=false;
If Match then
I:=I+1;
end;
end;
WildStrComp:=Match;
end;
function FileNameScan(S:Str80):Str80;
var
T : FCB_Layout;
i : integer;
Regs : Registers;
begin
S:=S+Chr(0);
with Regs do
begin
ah:=$29;
al:=0;
DS:=Seg(S);
SI:=Ofs(S)+1;
ES:=Seg(T);
DI:=Ofs(T);
end;
with T do
begin
for i:=1 to 8 do
FileName[i]:=' ';
for i:=1 to 3 do
FileExt[i]:=' ';
end;
MsDos(Regs);
with T do
begin
for i:=1 to 8 do
S[i]:=FileName[i];
S[9]:='.';
for i:=1 to 3 do
S[9+i]:=FileExt[i];
S[0]:=Chr(12);
end;
FileNameScan:=S;
end;
procedure FileMaskScan(var S:Str80);
begin
S:=FileNameScan(S);
end;
{*I fillzero.pas}
procedure FillZero(var S:AnyString);
var
I : integer;
begin
for I:=1 to Length(S) do
If S[I]=' ' then
S[I]:='0';
end;
{*I dirutil.pas }
type
BiosString = String[80];
DateStr = String[8];
TimeStr = String[8];
function DecodeDiskDate(I:integer):DateStr;
var
D : DateStr;
K : integer;
S : String[2];
begin
D:='';
If I<>0 then
begin
K:=(I shr 5) and $0F;
Str(K:2,S);
D:=S;
K:=I and $1F;
Str(K:2,S);
D:=D+'/'+S+'/';
K:=(I shr 9);
Str(K+80:2,S);
D:=D+S;
FillZero(D);
end;
DecodeDiskDate:=D;
end;
function DecodeDiskTime(I:integer):TimeStr;
var
D : TimeStr;
K : integer;
S : String[2];
begin
K:=(I shr 11);
If K>12 then
K:=K-12
else
If K=0 then
K:=12;
Str(K:2,S);
D:=S+':';
K:=(I shr 5) and $3F;
Str(K:2,S);
D:=D+S;
FillZero(D);
K:=(I shr 11);
If K>12 then D:=D+' pm'
else If K=12 then D:=D+' m'
else D:=D+' am';
DecodeDiskTime:=D;
end;
procedure ExtractFileInfo(var DTABuffer:BiosString;var DirFlag:boolean;
var FileSize:Real;var Attr:integer;
var Day:DateStr; var Tme:TimeStr);
Var
Tmp : Real;
Begin
DirFlag:=false;
FileSize:=0.0;
Attr:=Ord(DTABuffer[21]);
Day:=DecodeDiskDate(Ord(DTABuffer[24])+swap(Ord(DTABuffer[25])));
Tme:=DecodeDiskTime(Ord(DTABuffer[22])+swap(Ord(DTABuffer[23])));
If (Attr and $10)<>0 then
DirFlag:=true
else
begin
FileSize:=Ord(DTABuffer[26])+(Ord(DTABuffer[27])*256.0);
Tmp:=Ord(DTABuffer[28])+(Ord(DTABuffer[29])*256.0);
if Tmp<>0 then
FileSize:=(Tmp*65535.0)+FileSize;
end;
end;
procedure SearchDir(DirMask:BiosString;var FileMask:BiosString;
var Option:Integer;var SubDir:boolean);
Var
SaveDTASeg,
SaveDTAOfs,
FileCount,
Attr,
Error : Integer;
FirstTime,
PrintFlag,
Dir : boolean;
DirCur,
DTABuffer,
FileName : BiosString;
FileSize,
Total : Real;
Date : DateStr;
Time : TimeStr;
begin
FirstTime:=true;
DirCur:=DirMask+'*.*'+Chr(0);
GetDTA(SaveDTASeg,SaveDTAOfs,Error);
SetDTA(Seg(DTABuffer),Ofs(DTABuffer),Error);
GetFirstFile(DirCur,FileName,Seg(DTABuffer),Ofs(DTABuffer),Option,Error);
Total:=0.0;
FileCount:=0;
If Error=0 then
begin
PrintFlag:=WildStrComp(FileNameScan(Copy(FileName,1,Length(FileName)-1)),
FileMask);
If PrintFlag and FirstTime then
begin
FirstTime:=False;
Writeln('Directory : ',DirMask,FileMask);
end;
ExtractFileInfo(DTABuffer,Dir,FileSize,Attr,Date,Time);
If PrintFlag then
begin
write(FileName,'':(14-length(FileName)),'<',Copy(Hexout(Attr),3,2),'>');
If Not Dir then
write('':3,FileSize:8:0,' ',Date:8,' ',Time)
else
write('':3,'<DIR> ',Date:8,' ',Time);
writeln;
Total:=Total+FileSize;
FileCount:=FileCount+1;
end;
If Dir and SubDir and (FileName[1]<>'.') then
begin
FileName:=Copy(FileName,1,Length(FileName)-1);
SearchDir(DirMask+FileName+'\',FileMask,Option,SubDir);
end
end;
While Error=0 do
begin
GetNextFile(FileName,Seg(DTABuffer),Ofs(DTABuffer),Option,Error);
If Error=0 then
begin
PrintFlag:=WildStrComp(FileNameScan(Copy(FileName,1,Length(FileName)-1)),
FileMask);
If PrintFlag and FirstTime then
begin
FirstTime:=False;
Writeln('Directory : ',DirMask,FileMask);
end;
ExtractFileInfo(DTABuffer,Dir,FileSize,Attr,Date,Time);
If PrintFlag then
begin
write(FileName,'':(14-length(FileName)),'<',Copy(Hexout(Attr),3,2),'>');
If Not Dir then
write('':3,FileSize:8:0,' ',Date:8,' ',Time)
else
write('':3,'<DIR> ',Date:8,' ',Time);
writeln;
Total:=Total+FileSize;
FileCount:=FileCount+1;
end;
If Dir and SubDir and (FileName[1]<>'.') then
begin
FileName:=Copy(FileName,1,Length(FileName)-1);
SearchDir(DirMask+FileName+'\',FileMask,Option,SubDir);
end;
end;
end;
SetDTA(SaveDTASeg,SaveDTAOfs,Error);
If Not FirstTime then
begin
Writeln('Total for : ',DirMask,FileMask);
Writeln(FileCount,' File(s) with ',Total:10:0,' Byte(s)');
end;
end;
begin
No:=ParamCount;
If No>0 then
begin
Parse(Sline,No,Entries);
If No=3 then
begin
DirMask:=Entries[1];
FileMask:=Entries[2];
Subs:=Entries[3];
end
else
If No=2 then
begin
DirMask:=Entries[1];
FileMask:=Entries[2];
Subs:='N';
end
else
If No=1 then
begin
GetCurrentDir(DirMask,Error);
DirMask:=Copy(DirMask,1,Length(DirMask)-1);
If DirMask='' then DirMask:='\' else
DirMask:='\'+DirMask+'\';
FileMask:=Entries[1];
Subs:='N';
end
else
No:=0;
end;
Repeat
If No=0 then
begin
Writeln(Con);
Write(Con,'Dir : ');
Readln(Con,DirMask);
Write(Con,'File Mask : ');
Readln(Con,FileMask);
Write(Con,'Search Sub-Directories (Y/N) :');
Readln(Con,Subs);
end;
I:=16;
SubDir:=(UpCase(Subs)='Y');
FileMaskScan(FileMask);
SearchDir(DirMask,FileMask,I,SubDir);
If No=0 then
begin
Write(Con,'Continue Y/N:');
Readln(Con,Continue);
end;
Until (UpCase(Continue)='N') or (No<>0);
end.